PC-SIG Library 8

home *** CD-ROM | disk | FTP | other *** search

/ PC-SIG Library 8 / PC-SIG Library CD-ROM (8th Edition) (1990-04).iso / 201_300 / disk0214 / form.bas < prev next >

Wrap

BASIC Source File | 1983-03-10 | 13.5 KB | 489 lines

3 DEFDBL X 4 DEFINT A-W,Y-Z 5 DIM F$(15),FLDN$(15,30),FTY(15,30),FL(15,30) 10 DIM X$(30),Y$(30) 13 DIM L(15),NREC(15),Z$(30) 14 DIM X(30),CK$(30),SN$(30),SFN(30),DTOPT(10) 16 DIM KY(15,30),KEYLIST(15,30),L$(10,100),LEND(30),CL(30) 18 DIM SU%(40),S!(30),FORM$(30) 19 DIM EN(80),CE(80,10),TE(80,10),Q$(80,10) 20 DIM XL(40) 21 DIM TX(6,20) 25 DIM S#(30) 35 DIM K$(80) 40 DIM EFN(10,80),MAXK(30) 61 CH = 29: PRINT FRE(0) 70 NE = 0 75 GOSUB 50000 80 GOSUB 10000 90 GOTO 30000 2300 REM ************** DISK SELECTION *************** 2302 IF HDISK = 2 THEN GOSUB 13000 2303 IF HDISK = 2 THEN GOTO 2360 2304 PRINT "" 2305 PRINT "************ WHICH DISK DRIVE IS THE FILE ON **************" 2310 PRINT "" 2315 PRINT " 1 - DISK DRIVE A" 2320 PRINT " 2 - DISK DRIVE B" 2325 PRINT " 3 - DISK DRIVE C" 2330 PRINT " 4 - DISK DRIVE D" 2335 PRINT "" 2340 PRINT "*********** ENTER THE NUMBER THEN PRESS RETURN ************" 2345 GOSUB 14000 2347 IF DT# < 0 OR DT#>4 GOTO 2345 2350 T = DT# 2355 ON T GOTO 2360,2370,2380,2390 2360 T$ = F$(A) 2365 GOTO 2490 2370 T$ = "B:"+F$(A) 2375 GOTO 2490 2380 T$ = "C:"+F$(A) 2385 GOTO 2490 2390 T$ = "D:"+F$(A) 2490 RETURN 2500 REM ******* OPEN FILE SUBROUTINE ******* 2503 CLOSE #1 2505 OPEN "R",#1,T$,L(A) 2507 D = 0 2510 FOR T = 1 TO NREC(A) 2520 FIELD #1,D AS DY$,FL(A,T) AS X$(T) 2530 D = D + FL(A,T) 2540 NEXT T 2543 GOSUB 7800 2545 RETURN 2550 REM ******* OPEN SECOND FILE ******* 2553 CLOSE #2 2555 OPEN "R",#2,T$,L(B) 2557 D = 0 2560 FOR T = 1 TO NREC(B) 2565 FIELD #2,D AS DY$,FL(B,T) AS Y$(T) 2570 D = D + FL(B,T) 2575 NEXT T 2578 RETURN 2580 REM ******* OPEN THIRD FILE ******* 2582 PRINT C,F$(C),L(C) 2584 OPEN "R",#2,F$(C),L(C) 2586 D = 0 2588 FOR T = 1 TO NREC(C) 2590 FIELD #2,D AS DY$,FL(C,T) AS Z$(T) 2592 D = D + FL(C,T) 2594 NEXT T 2596 RETURN 7800 MRN = LOF(1)/ L(A) 7805 REM MRN = INT(MRN) 7810 RETURN 7900 REM ***** LOF 7910 MRN2 = LOF(3)/82 7920 RETURN 7950 REM ******* LOF 7960 MRNS = LOF(B)/L(B) 7970 RETURN 10000 REM ************* READ SUBROUTINE ************* 10004 GOSUB 10900 10010 OPEN "I",#1,"FFILE" 10020 INPUT #1,MAXF 10030 FOR A = 1 TO MAXF 10040 INPUT #1,A,F$(A),NREC(A),L(A) 10050 FOR N = 1 TO NREC(A) 10060 INPUT #1,FLDN$(A,N),FTY(A,N),FL(A,N) 10070 IF FTY(A,N) = 2 THEN INPUT #1,KY(A,N),KEYLIST(A,N) 10080 NEXT N 10090 NEXT A 10100 CLOSE #1 10110 RETURN 10900 REM ************* PUT DISK IN DRIVE SUB 10905 IF HDISK = 2 THEN RETURN 10910 GOSUB 13000 10920 PRINT " ******** PUT PROGRAM DATA DISK IN THE DEFAULT DISK DRIVE *********" 10930 PRINT "" 10940 PRINT " THEN PRESS ANY KEY TO CONTINUE " 10950 PRINT "" 10960 PRINT " If the program data disk is already in the default disk drive then" 10965 PRINT " just press any key to continue." 10970 PRINT "" 10990 IF INKEY$ = "" GOTO 10990 10995 RETURN 11000 REM ******** LOAD KEYLIST ********* 11010 GOSUB 13000 11100 A = 10 11105 PRINT "FILE : KEYLIST " 11110 GOSUB 2300 11120 GOSUB 2500 11130 FOR T = 1 TO 10000 11140 IF T > MRN GOTO 11900 11150 GET #1,T 11160 T1 = CVI(X$(1)) 11170 T2 = CVI(X$(2)) 11180 L$(T1,T2) = X$(3) 11185 IF T2 > MAXK(T1) THEN MAXK(T1) = T2 11190 NEXT T 11900 KD = 5 11935 CLOSE #1 11940 RETURN 13000 REM ********* CLEAR SCREEN 13010 CLS 13020 RETURN 13100 REM ********* LOCATE 13110 LOCATE LI,1 13120 RETURN 13200 FOR T% = 1 TO 80 13210 PRINT CHR$(8); 13220 NEXT T% 13222 FOR T% = 1 TO 24 13223 PRINT CHR$(11); 13224 NEXT T% 13225 LI = LI - 1 13230 FOR T% = 1 TO LI 13240 PRINT CHR$(0) 13250 NEXT T% 13590 RETURN 13600 REM ****** CHECK FOR ASC0 13610 S4$ = INKEY$ 13620 C2 = ASC(S4$) 13630 IF C2 = 83 THEN C = 1 13640 IF C2 = 82 THEN C = 6 13650 IF C2 = 75 THEN C = 19 13660 IF C2 = 77 THEN C = 4 13670 RETURN 14000 REM ******* INTEGER LESS THEN 100 CHECK ******** 14010 MAX = 2 14020 ACT$ = "1234567890=<>^" 14023 IF NE = 0 THEN ACT$ = "1234567890" 14025 PRINT ">__<"; 14030 GOTO 14500 14100 REM ******* INTEGER ******* 14110 MAX = 8 14120 ACT$ = "1234567890-+,=<>^" 14123 IF NE = 0 THEN ACT$ = "1234567890-+," 14125 PRINT ">________<"; 14130 GOTO 14500 14200 REM ******* SINGLE PRECISION ******* 14210 MAX = 10 14220 ACT$ = "1234567890-+,.%$=<>^" 14223 IF NE = 0 THEN ACT$ = "1234567890+-,.%$" 14225 PRINT ">__________<"; 14230 GOTO 14500 14300 REM ******* DOUBLE PRECISION ******* 14310 MAX = 20 14320 ACT$ = "1234567890-+,.%$=<>^" 14323 IF NE = 0 THEN ACT$ = "1234567890+-,.%$" 14325 PRINT ">____________________<"; 14330 GOTO 14500 14500 REM ********** NUMBER CHECK ********** 14505 A$ = "" 14510 K$(20) = " " 14515 KTMAX = 0 14520 FOR T9 = 1 TO MAX 14525 K$(T9) = " " 14530 NEXT T9 14535 DIG$ = "1234567890." 14540 DOTFLG = 0 14541 T2 = MAX + 1 14542 FOR T6 = 1 TO T2 14544 PRINT CHR$(CH); 14546 NEXT T6 14550 IF INKEY$ = "" GOTO 14560 ELSE GOTO 14550 14560 KT = 0 14565 REM *********** CHECK ALFANUMERIC INPUT FOR LENGTH *********** 14570 KT = KT + 1 14575 REM 14580 W$ = INKEY$ 14585 IF W$ = "" GOTO 14580 14590 C = ASC(W$) 14593 IF C = 0 THEN GOSUB 13600 14595 IF C = 13 GOTO 14660 14600 IF C = 17 OR C = 8 GOTO 14860 14605 IF C = 19 GOTO 14690 14610 IF C = 4 GOTO 14710 14615 IF C = 6 GOTO 14730 14620 IF C = 1 GOTO 14790 14625 IF KT > MAX GOTO 14575 14630 IF INSTR(ACT$,W$) = 0 GOTO 14890 14635 K$(KT) = W$ 14645 PRINT K$(KT); 14650 IF KT > KTMAX THEN KTMAX = KT 14655 GOTO 14570 14660 REM ********** RETURN ********** 14670 FOR T9 = 1 TO KTMAX 14675 A$ = A$ + K$(T9) 14680 NEXT T9 14681 IF KTMAX = 0 THEN PRINT "1" 14682 IF KTMAX = 0 THEN DT# = 1 14683 IF KTMAX = 0 THEN RETURN 14684 PRINT "" 14685 GOTO 14905 14690 REM ********* MOVE CURSE BACK ******** 14695 IF KT = 1 GOTO 14575 14700 KT = KT - 1 14703 PRINT CHR$(CH); 14705 GOTO 14575 14710 REM ********* MOVE CURSER FORWARD ********* 14715 IF KT >= MAX GOTO 14575 14716 IF KT > (KTMAX + 1) GOTO 14575 14718 PRINT K$(KT); 14720 KT = KT + 1 14725 GOTO 14575 14730 REM ********** INSERT *********** 14733 IF KT > KTMAX GOTO 14575 14735 X9 = MAX 14740 WHILE X9 > KT 14745 X9 = X9 - 1 14750 K$(X9 + 1) = K$(X9) 14755 WEND 14760 K$(KT) = " " 14767 KTMAX = KTMAX + 1 14769 IF KTMAX > MAX THEN KTMAX = MAX 14770 FOR T9 = KT TO KTMAX 14775 PRINT K$(T9); 14780 NEXT T9 14781 T6 = (KTMAX - KT) + 1 14782 FOR T7 = 1 TO T6 14783 PRINT CHR$(CH); 14784 NEXT T7 14785 GOTO 14575 14790 REM ********** DELETE *********** 14793 IF KT > KTMAX GOTO 14575 14794 IF KTMAX = 1 GOTO 14575 14795 K$(MAX + 1) = "" 14800 X9 = KT 14805 WHILE X9 <= MAX 14810 K$(X9) = K$(X9 + 1) 14815 X9 = X9 + 1 14820 WEND 14830 KTMAX = KTMAX - 1 14835 FOR T9 = KT TO KTMAX 14840 PRINT K$(T9); 14845 NEXT T9 14850 PRINT "_"; 14851 T7 = (KTMAX - KT) + 2 14852 FOR T8 = 1 TO T7 14853 PRINT CHR$(CH); 14854 NEXT T8 14855 GOTO 14575 14860 REM ********* BACKSPACE ******** 14865 IF KT = 1 GOTO 14575 14870 KT = KT - 1 14875 PRINT CHR$(CH); 14877 K$(KT) = " " 14880 PRINT "_"; 14883 PRINT CHR$(CH); 14885 GOTO 14575 14890 REM ******* INPUT NOT ACCEPTABLE ******** 14895 PRINT CHR$(7); 14900 GOTO 14580 14905 REM ********* CLEAR STRINGS ******** 14910 MAX = LEN(A$) 14915 D2$ = "" 14920 D1$ = "" 14925 DFLG = 0 14930 FOR Q93 = 1 TO MAX 14935 R$ = MID$(A$,Q93,1) 14940 IF INSTR(DIG$,R$) = 0 GOTO 14975 14945 IF R$ = "." OR DFLG = 1 GOTO 14965 14950 IF DFLG = 1 GOTO 14965 14955 D2$ = D2$ + R$ 14960 GOTO 14975 14965 D1$ = D1$ + R$ 14970 DFLG = 1 14975 NEXT Q93 14980 DA# = VAL(D2$) 14985 D1# = VAL(D1$) 14990 DT# = DA# + D1# 14995 IF K$(1) = "-" THEN DT# = -DT# 14997 RETURN 16010 PRINT "*********** MAKE SURE YOUR PRINTER IS ON **************" 16020 PRINT "" 16030 PRINT "******************** WITH PAPER ***********************" 16040 PRINT "" 16050 PRINT "********** PRESS ANY KEY TO START PRINTING ************" 16055 PRINT "" 16057 PRINT " ******* PRESS THE LETTER A TO ABORT *******" 16070 T$ = INKEY$ 16073 IF T$ = "" GOTO 16070 16075 PRINT T$ 16085 IF T$ = "A" THEN GOTO 30000 16090 RETURN 16200 REM ********* PRINT OUT FIELDS 16205 T2 = 1 16210 FOR T = 1 TO NREC(A) 16220 PRINT TAB(T2) T;"-";FLDN$(A,T); 16230 IF T MOD 3 = 0 THEN PRINT "" 16235 IF T MOD 3 = 0 THEN T2 = -25 16237 T2 = T2 + 26 16340 NEXT T 16350 RETURN 26100 EFLG = 1 26200 PRINT "********** END OF FILE ***********" 26202 PRINT "**** PRESS ANY KEY TO CONTINUE ****" 26204 IF INKEY$ = "" GOTO 26204 26500 REM ********* ON ERROR SUBROUTINE *********** 26600 PRINT "********** END OF FILE ***********" 26610 PRINT "**** PRESS ANY KEY TO CONTINUE ****" 26620 IF INKEY$ = "" GOTO 26620 26635 EFLG = 1 26640 RETURN 26800 REM ********** ON ERROR GOTO ************** 26900 PRINT "************ RECORD NOT FOUND *************" 30000 REM ********** FORM OUTPUT *********** 30003 CLOSE 30005 IF KD <> 5 THEN GOSUB 11000 30010 GOSUB 30300 30100 GOSUB 13000 30110 PRINT "************ PRINT A CUSTOM FORM *************" 30120 PRINT "" 30130 PRINT "****** ENTER ZERO TO EXIT THE PROGRAM *******" 30140 GOSUB 30380 30150 PRINT "******* WHAT FORM DO YOU WANT TO PRINT ? ******" 30155 GOSUB 14000 30156 IF DT# <0 OR DT# >MAXFORM GOTO 30155 30160 T = DT# 30165 IF DT# = 0 GOTO 51000 30170 N$ = FORM$(T) 30175 CLOSE 30180 GOTO 30900 30300 REM ********* INPUT LIST OF FORMS FROM DISK ********* 30305 GOSUB 10900 30310 OPEN "I",#1,"FORMLIST" 30320 INPUT #1,MAXFORM 30330 FOR T = 1 TO MAXFORM 30340 INPUT #1,FORM$(T) 30350 NEXT T 30360 CLOSE #1 30370 RETURN 30380 REM ******* PRINT FORM LIST ******* 30390 FOR T = 1 TO MAXFORM 30400 PRINT T;"-";FORM$(T) 30410 NEXT T 30420 RETURN 30900 REM ***** 31000 REM ********** READ DATA ON FILE *********** 31005 OPEN "I",#1,N$ 31010 INPUT #1,LN,MF,SFO 31015 IF SFO = 1 THEN INPUT #1,TMF,TSF,SF 31020 FOR T1 = 1 TO LN 31025 INPUT #1,EN(T1) 31030 FOR T2 = 1 TO EN(T1) 31035 INPUT #1,CE(T1,T2),TE(T1,T2) 31040 ON TE(T1,T2) GOTO 31045,31055,31065,31075,31075 31045 INPUT #1,Q$(T1,T2) 31050 GOTO 31075 31055 INPUT #1,EFN(T1,T2) 31060 GOTO 31075 31065 INPUT #1,EFN(T1,T2) 31070 GOTO 31075 31075 NEXT T2 31080 NEXT T1 31085 CLOSE 31160 GOSUB 13000 31161 A = MF 31162 PRINT "MAIN FILE = ";F$(A) 31164 GOSUB 2300 31166 GOSUB 2500 31170 GOSUB 13000 31171 GOTO 31300 31300 REM ****** END ON ERROR ROUTINE ****** 31310 GOSUB 13000 31320 PRINT " CUSTOM FORM ";N$ 31330 PRINT " MAIN FILE ";F$(MF) 31350 PRINT "" 31360 PRINT "***** WHAT RECORD DO YOU WANT TO START AT *****" 31362 GOSUB 14100 31364 RNS = DT# 31365 A = MF 31366 GOSUB 7800 31367 IF DT# <1 OR DT# >10000 GOTO 31362 31368 PRINT "THE HIGHEST RECORD NUMBER IS ";MRN 31370 PRINT "****** WHAT RECORD DO YOU WANT TO STOP AT ******" 31372 GOSUB 14100 31373 IF DT# <RNS OR DT# >MRN GOTO 31372 31374 RNF = DT# 31380 IF RNF > MRN GOTO 31370 31400 REM ******** START FORM LOOP ******** 31410 FOR T = RNS TO RNF 31415 GET #1,T 31420 GOSUB 32000 31430 IF INKEY$ = "" GOTO 31450 31440 GOSUB 31500 31450 NEXT T 31460 GOTO 30100 31500 REM ********** PAUSE ROUTINE ************ 31510 PRINT "************* PAUSE ROUTINE **************" 31520 PRINT " 1 - CONTINUE PRINTING FORMS " 31530 PRINT " 2 - DONE BACK TO INITIAL MENU " 31540 PRINT "*** ENTER THE NUMBER THEN PRESS RETURN ***" 31550 GOSUB 14000 31552 IF DT# <1 OR DT# >2 GOTO 31550 31560 IF DT# = 1 THEN RETURN 31570 CLOSE 31580 GOTO 30000 32000 REM *********** PRINT FORM ********************* 32100 FOR L = 1 TO LN 32110 GOSUB 32200 32115 LPRINT "" 32120 NEXT L 32130 RETURN 32200 FOR E = 1 TO EN(L) 32210 GOSUB 32300 32220 Z$ = INKEY$ 32225 IF Z$ = "" GOTO 32230 32227 GOSUB 31500 32230 NEXT E 32240 RETURN 32300 REM ******** 32310 C = CE(L,E) 32320 ON TE(L,E) GOTO 32400,32600,32800,33500,33200 32400 REM ****** STRING CONSTANT ****** 32410 LPRINT TAB(C) Q$(L,E); 32420 GOTO 33500 32600 REM ****** GET FROM MAIN FILE ****** 32610 F = EFN(L,E) 32620 ON FTY(MF,F) GOTO 32630,32660,32700,32750,32790 32630 REM ***** String ***** 32635 LPRINT TAB(C) X$(F); 32640 GOTO 33500 32660 REM ***** INTEGER ****** 32665 I% = CVI(X$(F)) 32670 LPRINT TAB(C) I%; 32675 GOTO 33500 32700 REM ***** SINGLE PRECISION ***** 32710 I! = CVS(X$(F)) 32720 LPRINT TAB(C) I!; 32730 GOTO 33500 32750 REM ***** DOUBLE PRECISION ****** 32760 I# = CVD(X$(F)) 32770 LPRINT TAB(C) I#; 32780 GOTO 33500 32790 REM ***** DOLLARS AND CENTS ****** 32792 I# = CVD(X$(F)) 32793 LPRINT TAB(C) ; 32794 LPRINT USING "**$########,.##";I#; 32796 GOTO 33500 32800 REM ****** GET FROM SECONDARY FILE ****** 32810 F = EFN(L,E) 32830 I% = CVI(X$(F)) 32832 T1 = KEYLIST(MF,F) 32835 W$ = L$(T1,I%) 32840 LPRINT TAB(C) W$; 33200 REM ****** BLANK LINE ****** 33500 RETURN 50000 REM ********** INTRO 50010 GOSUB 13000 50100 PRINT " P R I N T F O R M P R O G R A M 3.0 " 50105 PRINT "" 50110 PRINT " Copyright 1984 by Potomac Pacific Engineering Inc." 50120 PRINT "" 50130 PRINT "This program is licensed FREE to all users with some restrictions " 50165 PRINT " See the manual for more information on the license." 50167 PRINT "" 50950 PRINT "****************** PRESS ANY KEY TO CONTINUE ******************"; 50960 IF INKEY$ = "" GOTO 50960 50970 RETURN 51000 REM ******** EXIT 51100 GOSUB 13000 51200 PRINT "BYE - Have a nice day " 51300 END Y$ = "" GOTO 50960 50970 RETURN 51000 REM ******** EXIT 51100 GOSUB 13000 512